home *** CD-ROM | disk | FTP | other *** search
/ ADA Programming Guide / ADA Programming Guide.iso / ada_gwu / pretty / test2.ada < prev   
Text File  |  1996-01-30  |  2KB  |  82 lines
  1. procedure display_menu (title:in string; options:in menus;
  2.  choice:out alpha_numerics) is
  3. left_column:constant:=15;
  4. right_column:constant:=20;
  5. prompt:constant string:=" ==> ";
  6. type alpha_array is array(alpha_numerics) of boolean;
  7. valid:boolean;
  8. valid_option:alpha_array:=(others=>false);
  9.  
  10. procedure draw_menu(title:string;options:menus)is
  11. begin
  12. new_page;
  13. new_line;
  14. set_col(right_column);
  15. put_line(title);
  16. new_line;
  17. for choice in alpha_numerics loop
  18. if options(choice)/=empty_line then
  19. valid_option(choice):=true;
  20. set_col(left_column);
  21. put(choice&" -- ");
  22. put_line(options(choice));
  23. end if;
  24. end loop;
  25. end draw_menu;
  26.  
  27. procedure get_response(valid:out boolean;choice:out alpha_numerics) is
  28. buffer_size:constant:=20;
  29. dummy:constant alpha_numerics:='X';
  30. first_char:character;
  31. buffer:string(1..buffer_size);
  32. -- Notes
  33. --
  34. --
  35. last:natural;
  36. index:positive;
  37.  
  38. function upper_case(current_char:character)return character is
  39. case_difference:constant:=16#20#;
  40. begin
  41. if current_char in 'a'..'z' then
  42. return character'val (character'pos(current_char)-case_difference);
  43. else
  44. return current_char;
  45. end if;
  46. end upper_case;
  47.  
  48. begin -- get_response
  49.  new_line;
  50. set_col(left_column);
  51. put(prompt);
  52. get_line(buffer,last);
  53. index:=positive'first;
  54. loop
  55. exit when((index>= lst) or else (buffer(index) in alpha_numerics));
  56. index:=positive'succ(index);
  57. end loop;
  58. first_char:= upper_case(buffer(index));
  59. if (first_char not in alpha_numerics) or
  60. else(not valid_option(first_char)) then
  61. valid:=false;
  62. choice:=dummy;
  63. elsevalid:=true;
  64.  choice:=first_char;
  65. end if;
  66. end get_response;
  67.  
  68. procedure beep is
  69. begin
  70. put(ascii.bel);
  71. end beep;
  72.  
  73. begin
  74. loop
  75. draw_menu(title,options);
  76. get_response(valid,choice);
  77. exit when valid;
  78. beep;
  79. end loop;
  80. end display_menu;
  81.  
  82.